home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #2
/
Monster Media No. 2 (Monster Media)(1994).ISO
/
prog_bas
/
vbint.zip
/
INTDEMO.FRM
< prev
next >
Wrap
Text File
|
1994-06-04
|
13KB
|
533 lines
VERSION 2.00
Begin Form IntDemo
AutoRedraw = -1 'True
Caption = "DOS Interrupt Test"
ClientHeight = 5295
ClientLeft = 990
ClientTop = 1470
ClientWidth = 7005
Height = 5700
Icon = INTDEMO.FRX:0000
Left = 930
LinkTopic = "Form1"
ScaleHeight = 5295
ScaleWidth = 7005
Top = 1125
Width = 7125
Begin CommandButton bCmd
Caption = "Dir &Listing"
Height = 495
Index = 6
Left = 5280
TabIndex = 5
Top = 3060
Width = 1545
End
Begin Timer Timer1
Enabled = 0 'False
Interval = 750
Left = 4500
Top = 30
End
Begin CommandButton bCmd
Caption = "Dir &Tree"
Height = 495
Index = 4
Left = 5280
TabIndex = 4
Top = 2490
Width = 1545
End
Begin ListBox List1
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 4125
Left = 300
TabIndex = 9
Top = 960
Visible = 0 'False
Width = 4635
End
Begin CommandButton bCmd
Caption = "&FindFirst/Next"
Height = 495
Index = 3
Left = 5280
TabIndex = 3
Top = 1920
Width = 1545
End
Begin TextBox Text1
Height = 345
Left = 300
TabIndex = 8
Text = "Text1"
Top = 480
Visible = 0 'False
Width = 4635
End
Begin CommandButton bCmd
Caption = "D&OS ""Stuff"""
Height = 495
Index = 2
Left = 5280
TabIndex = 0
Top = 210
Width = 1545
End
Begin CommandButton bCmd
Cancel = -1 'True
Caption = "E&xit"
Height = 495
Index = 5
Left = 5280
TabIndex = 6
Top = 4590
Width = 1545
End
Begin CommandButton bCmd
Caption = "Get &Space"
Height = 495
Index = 1
Left = 5280
TabIndex = 1
Top = 780
Width = 1545
End
Begin CommandButton bCmd
Caption = "Get Cur&Dirs"
Height = 495
Index = 0
Left = 5280
TabIndex = 2
Top = 1350
Width = 1545
End
Begin Image Image1
Height = 975
Left = 5520
Stretch = -1 'True
Top = 3600
Width = 1065
End
Begin Label Label1
AutoSize = -1 'True
Caption = "Label1"
Height = 195
Left = 300
TabIndex = 7
Top = 210
Visible = 0 'False
Width = 585
End
End
'---------------------------------------------------------------------------
' DOS Interrupt Demo Program, Copyright (c) 1994 Karl E. Peterson
' Redistributed by permission.
'
' Requires: VBInt.DLL, VBRun300.DLL
'
' This program may be distributed freely on the condition that it is
' distributed in full, and unmodified, and that no fee is charged for such
' distribution with the exception of reasonable media and shipping charges.
' Any or all portions of the source code may be incorporated into your own
' programs, and those programs may be distributed without payment of
' royalties on the condition that such programs differ substantially from
' this demonstration program.
'
' This program is distributed AS IS. The author acknowledges absolutely
' no liability for its use or misuse. The sole purpose of this program is to
' demonstrate some of the powerful capabilities of VBInt.DLL, written and
' copyrighted by Rick Esterling. Calling DOS interrupts from Windows is
' fairly "non-standard" behavior. Users of this program acknowledge that
' they are doing so at their OWN RISK.
'
' This demonstration program was created and distributed by:
' Karl E. Peterson
' Regional Transportation Council
' 1351 Officers' Row
' Vancouver, Washington 98661
' CompuServe: 72302,3707
'
' Your comments or questions are invited!
'---------------------------------------------------------------------------
Option Explicit
DefInt A-Z
Const bDirs = 0
Const bSpace = 1
Const bDOS = 2
Const bFind = 3
Const bTree = 4
Const bList = 6
Const bExit = 5
Dim DtaEstablished%
Sub bCmd_Click (Index As Integer)
Screen.MousePointer = 11
Cls
Select Case Index
Case bDirs, bSpace, bDOS, bExit
Text1.Visible = False
Label1.Visible = False
List1.Visible = False
Select Case Index
Case bDirs: ShowCurrentDirs
Case bSpace: ShowFreeSpace
Case bDOS: ShowDosStuff
Case bExit: Unload Me
End Select
Case bFind
List1.Visible = False
Text1 = "C:\*.*"
Text1.Visible = True
Label1 = "FileSpec to Find (press Enter for each match):"
Label1.Visible = True
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
Timer1.Enabled = True
DtaEstablished = False
Case bTree, bList
Text1.Visible = True
Label1.Visible = True
List1.Visible = True
Select Case Index
Case bTree
Text1 = "C:"
Label1 = "Drive to Search (press Enter to begin scan):"
Refresh
ShowDirTree (Text1), List1
Case bList
Text1 = "C:\"
Label1 = "Directory to Search (press Enter to begin scan):"
Refresh
ShowDirList (Text1), List1
End Select
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Select
Screen.MousePointer = 0
End Sub
Sub Form_Load ()
Dim Proceed%, m$
Proceed = IDYES
If WinIsNT() Then
m$ = "Running under Windows NT!" + Chr$(13) + Chr$(10)
m$ = m$ + "Do you wish to continue?"
Proceed = MsgBox(m$, MB_YESNO + MB_ICONEXCLAMATION + MB_DEFBUTTON2, "Warning")
End If
If Proceed = IDYES Then
DosVersion = DosGetVersion()
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
SetTabs List1
Show
bCmd_Click bDOS
Else
Unload Me
End If
Image1.Picture = Me.Icon
End Sub
Sub SetColor (Bold%)
If Bold Then
ForeColor = &H80000008
Else
ForeColor = RGB(128, 128, 128)
End If
End Sub
Sub SetTabs (Lst As ListBox)
ReDim Tabs(0 To 4) As Integer
Dim Rtn%
Tabs(0) = 60
Tabs(1) = 100
Tabs(2) = 140
Tabs(3) = 180
Tabs(4) = 220
Rtn = SendMessage(Lst.hWnd, LB_SETTABSTOPS, 5, Tabs(0))
End Sub
Sub ShowCurrentDirs ()
Dim i%, CurrDir$
Cls
For i = 1 To 26
ForeColor = RGB(128, 0, 0)
If DrvRemovable(Chr$(i + 64)) Then
Print "* ";
ElseIf DrvCDRom(Chr$(i + 64)) Then
Print "[CD]";
End If
If DrvGetDir(Chr$(i + 64), CurrDir$) Then
ForeColor = RGB(0, 0, 128)
Print "{" + DrvGetVolume$(Chr$(i + 64)) + "} ";
If DrvRemote(Chr$(i + 64)) Then
ForeColor = RGB(0, 128, 0)
Else
ForeColor = RGB(0, 0, 0)
End If
Print Chr$(i + 64) + ":" + CurrDir$
Else
ForeColor = RGB(128, 128, 128)
Print Chr$(i + 64) + ": -->" + CurrDir$
End If
Next i
ForeColor = RGB(128, 0, 0)
Print "* -- Removable Media ";
ForeColor = RGB(0, 0, 128)
Print "{Volume Label} ";
ForeColor = RGB(0, 128, 0)
Print "Remote Drive"
ForeColor = RGB(0, 0, 0)
End Sub
Sub ShowDirList (DirSpec$, Lst As ListBox)
Dim Files() As FileDataType
Dim i%
Screen.MousePointer = 11
Lst.Clear
Lst.Refresh
If Right$(DirSpec$, 1) <> "\" Then
DirSpec$ = DirSpec$ + "\*.*"
Else
DirSpec$ = DirSpec$ + "*.*"
End If
i = FillDirArray(DirSpec$, Files(), attrAllNorm, False, False)
If i Then
Lst.AddItem DosErrorMsg$(i)
Else
For i = LBound(Files) To UBound(Files)
Lst.AddItem FmtDirEntry$(Files(i))
Next i
End If
Screen.MousePointer = 0
End Sub
Sub ShowDirTree (Drive$, Lst As ListBox)
Dim Dirs() As String
Dim i%
Screen.MousePointer = 11
Lst.Clear
Lst.Refresh
FillDirTreeArray Dirs(), UCase$(Left$(Drive$, 1)) + ":\", 0
For i = LBound(Dirs) To UBound(Dirs)
Lst.AddItem Dirs(i)
Next i
Screen.MousePointer = 0
End Sub
Sub ShowDosStuff ()
Cls
Print "DOS Version " & Format$(DosVersion / 100, "#0.00")
If DosAnsiLoaded() Then
SetColor 1
Print "Ansi Loaded"
Else
SetColor 0
Print "Ansi NOT Loaded"
End If
If DosAppendLoaded() Then
SetColor 1
Print "Append Loaded"
Else
SetColor 0
Print "Append NOT Loaded"
End If
If DosAssignLoaded() Then
SetColor 1
Print "Assign Loaded"
Else
SetColor 0
Print "Assign NOT Loaded"
End If
If DosDblSpaceLoaded() Then
SetColor 1
Print "DblSpace Loaded"
Else
SetColor 0
Print "DblSpace NOT Loaded"
End If
If DosDosKeyLoaded() Then
SetColor 1
Print "DosKey Loaded"
Else
SetColor 0
Print "DosKey NOT Loaded"
End If
If DosHimemLoaded() Then
SetColor 1
Print "HiMem Loaded"
Else
SetColor 0
Print "HiMem NOT Loaded"
End If
If DosGraftablLoaded() Then
SetColor 1
Print "GrafTabl Loaded"
Else
SetColor 0
Print "GrafTabl NOT Loaded"
End If
If DosNetworkLoaded() Then
SetColor 1
Print "Network Loaded"
Else
SetColor 0
Print "Network NOT Loaded"
End If
If DosNlsfuncLoaded() Then
SetColor 1
Print "NlsFunc Loaded"
Else
SetColor 0
Print "NlsFunc NOT Loaded"
End If
If DosPrintLoaded() Then
SetColor 1
Print "Print Loaded"
Else
SetColor 0
Print "Print NOT Loaded"
End If
If DosShareLoaded() Then
SetColor 1
Print "Share Loaded"
Else
SetColor 0
Print "Share NOT Loaded"
End If
SetColor 1
End Sub
Sub ShowFileFound (Txt As TextBox, First%)
Static DTA As DTAType
Dim File As FileDataType
Dim ErrorCode%, Rtn%
If First Then
Rtn = FileFindFirst((Txt), DTA, attrAllFile, ErrorCode)
Else
Rtn = FileFindNext(DTA, attrAllFile, ErrorCode)
End If
Cls
CurrentY = Txt.Top + Txt.Height * 1.25
CurrentX = Txt.Left
If ErrorCode Then
Print DosErrorMsg$(ErrorCode)
DtaEstablished = False
Else
FileGetData DTA, File
Print File.FileName
CurrentX = Txt.Left
Print Format$(File.Size, "#,##0"); " bytes"
CurrentX = Txt.Left
Print Format$(File.sDate, "long date")
CurrentX = Txt.Left
Print Format$(File.sDate, "long time")
DtaEstablished = True
End If
Txt.SelStart = 0
Txt.SelLength = Len(Txt)
End Sub
Sub ShowFreeSpace ()
Dim i%, d$, sn$
Dim disk As DiskFreeSpaceType
Cls
For i = 1 To 26
d$ = Chr$(i + 64) + ": "
DrvFreeSpace d$, disk
If disk.totalBytes Then
Print d$;
If DrvCDRom(Chr$(i + 64)) Then
Print "[CD-ROM] 0 of ";
Else
Print Format$(disk.availableBytes, "#,##0");
Print " of ";
End If
Print Format$(disk.totalBytes, "#,##0"); " free ";
If DrvGetSerNum(d$, sn$) Then
Print "S/N:"; sn$
Else
Print
End If
End If
Next i
End Sub
Sub Text1_Change ()
Timer1.Enabled = False
DtaEstablished = False
End Sub
Sub Text1_KeyPress (KeyAscii As Integer)
If KeyAscii = 13 Then 'Enter
KeyAscii = 0
If InStr(Label1, "FileSpec") Then
Dim First%
If Not DtaEstablished Then First = True
ShowFileFound Text1, First
ElseIf InStr(Label1, "Drive") Then
ShowDirTree (Text1), List1
Else
ShowDirList (Text1), List1
End If
End If
End Sub
Sub Timer1_Timer ()
If ActiveControl Is Text1 Then
SendKeys "{Enter}"
End If
End Sub
